Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH6/SRC/LEASTSQ2.FRM

Text File | 1996-03-29 | 5KB | 194 lines

VERSION 4.00
Begin VB.Form LeastSquareForm
   Caption         =   "Quadratic Least Squares"
   ClientHeight    =   5310
   ClientLeft      =   2085
   ClientTop       =   900
   ClientWidth     =   4830
   Height          =   6000
   Left            =   2025
   LinkTopic       =   "Form1"
   ScaleHeight     =   354
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   322
   Top             =   270
   Width           =   4950
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   2040
      TabIndex        =   1
      Top             =   4920
      Width           =   615
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   4815
      Left            =   0
      ScaleHeight     =   317
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   317
      TabIndex        =   0
      Top             =   0
      Width           =   4815
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "LeastSquareForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Dim NumPts As Integer
Dim PtX() As Single
Dim PtY() As Single

' ************************************************
' Compute the a, b, and c values for the least
' squares quadratic.
' ************************************************
Sub GetLeastSquaresValues(num As Integer, x() As Single, Y() As Single, avalue As Single, bvalue As Single, cvalue As Single)
Dim A As Single
Dim B As Single
Dim C As Single
Dim D As Single
Dim E As Single
Dim F As Single
Dim G As Single
Dim x2 As Single
Dim x3 As Single
Dim x4 As Single
Dim C2BE As Single
Dim E2CN As Single
Dim BDAF As Single
Dim CFBG As Single
Dim ACB2 As Single
Dim denom As Single
Dim i As Integer

    ' Compute the sums.
    For i = 1 To NumPts
        x2 = PtX(i) * PtX(i)
        x3 = x2 * PtX(i)
        x4 = x2 * x2
        A = A + x4
        B = B + x3
        C = C + x2
        D = D + PtY(i) * x2
        E = E + PtX(i)
        F = F + PtY(i) * PtX(i)
        G = G + PtY(i)
    Next i

    ' Compute the quadratic parameters.
    C2BE = C * C - B * E
    E2CN = E * E - C * NumPts
    BDAF = B * D - A * F
    CFBG = C * F - B * G
    ACB2 = A * C - B * B
    denom = (B * C - A * E) * C2BE - _
            (C * E - B * NumPts) * (B * B - A * C)

    avalue = _
    ((C * D - B * F) * E2CN - (E * F - C * G) * C2BE) / _
    (ACB2 * E2CN + C2BE * C2BE)

    bvalue = _
    (CFBG * (B * C - A * E) - BDAF * (C * E - B * NumPts)) / _
    denom

    cvalue = _
    (BDAF * (C * C - B * E) + CFBG * ACB2) / _
    denom
End Sub





' ************************************************
' Add this point to the list of points.
' ************************************************
Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Const GAP = 2

    ' If this is the first point, erase the screen.
    If NumPts < 1 Then Canvas.Cls

    ' Record the new point.
    NumPts = NumPts + 1
    ReDim Preserve PtX(1 To NumPts)
    ReDim Preserve PtY(1 To NumPts)
    PtX(NumPts) = x
    PtY(NumPts) = Y

    ' Display the point.
    Canvas.Line (x - GAP, Y - GAP)-(x + GAP, Y + GAP), , BF

    ' If NumPts >= 2, enable the Go button.
    If NumPts >= 2 Then CmdGo.Enabled = True
End Sub


' ************************************************
' Draw the least squares fit curve.
' ************************************************
Private Sub CmdGo_Click()
    CmdGo.Enabled = False

    DrawCurve

    ' Prepare to get a new set of points.
    NumPts = 0
End Sub
' ************************************************
' Draw the least squares line.
' ************************************************
Sub DrawCurve()
Dim A As Single
Dim B As Single
Dim C As Single
Dim x1 As Single
Dim x2 As Single
Dim i As Integer
Dim x As Single
Dim dx As Single

    ' Get the parameters for the quadratic.
    GetLeastSquaresValues NumPts, PtX, PtY, A, B, C

    ' Find the minimum and maximum X values.
    x1 = PtX(1) ' This will be the minimum X value.
    x2 = x1     ' This will be the maximum X value.
    For i = 2 To NumPts
        If x1 > PtX(i) Then x1 = PtX(i)
        If x2 < PtX(i) Then x2 = PtX(i)
    Next i

    ' Draw the curve.
    Canvas.CurrentX = x1
    Canvas.CurrentY = A * x1 * x1 + B * x1 + C

    dx = (x2 - x1) / 100    ' Use 100 increments.
    x = x1 + dx
    Do While x < x2
        Canvas.Line -(x, A * x * x + B * x + C)
        x = x + dx
    Loop

    Canvas.Line -(x2, A * x2 * x2 + B * x2 + C)
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub